home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / scm / wb1a1.lha / wb / prev.scm < prev    next >
Encoding:
Text File  |  1993-06-29  |  10.5 KB  |  269 lines
  1. ; Wb-tree File Based Associative String Data Base System.
  2. ; Copyright (c) 1991, 1992, 1993 Holland Mark Martin
  3. ;
  4. ;Permission to use, copy, modify, and distribute this software and its
  5. ;documentation for educational, research, and non-profit purposes and
  6. ;without fee is hereby granted, provided that the above copyright
  7. ;notice appear in all copies and that both that copyright notice and
  8. ;this permission notice appear in supporting documentation, and that
  9. ;the name of Holland Mark Martin not be used in advertising or
  10. ;publicity pertaining to distribution of the software without specific,
  11. ;written prior consent in each case.  Permission to incorporate this
  12. ;software into commercial products can be obtained from Jonathan
  13. ;Finger, Holland Mark Martin, 174 Middlesex Turnpike, Burlington, MA,
  14. ;01803-4467, USA.  Holland Mark Martin makes no representations about
  15. ;the suitability or correctness of this software for any purpose.  It
  16. ;is provided "as is" without express or implied warranty.  Holland Mark
  17. ;Martin is under no obligation to provide any services, by way of
  18. ;maintenance, update, or otherwise.
  19.  
  20. (require (in-vicinity (program-vicinity) "sys"))
  21.  
  22. (define trace-on #f)
  23.  
  24. (define (match-str pkt)
  25.   (case (MATCH-TYPE pkt)
  26.     ((QPASTP)  "QPASTP")
  27.     ((PASTP) "PASTP")
  28.     ((MATCH) "MATCH")    
  29.     ((MATCHEND) "MATCHEND")
  30.     ((PASTEND) "PASTEND")
  31.     (else ">>>>ERROR<<<<")))
  32.  
  33. ;; CHAIN-PREV-FIND [was CHAIN-FIND-PREV] searches fwd from ENT looking for
  34. ;; key preceeding KEY-STR.
  35. ;; call with ENT in mode ACCESS, prev-ent=#f, prev-pos=0
  36. ;; if found, returns an ENT in mode ACCESS (match pos is in PKT, type=MATCH);
  37. ;; otherwise, returns an ENT in mode ACCESS, match type=PASTEND, POS=0
  38.  
  39. (define (chain-prev-find ent access key-str k-len pkt prev-ent prev-pos)
  40.   (let ((blk (ENT-BLK ent)))
  41.     (blk-find-pos blk key-str k-len pkt)
  42.     (if trace-on
  43.     (fprintf diagout "c-f-p blk=%d res=[%s mpos=%d kpos=%d ppos=%d] prev-ent=%d:%ld ppos=%d\\n"
  44.          (BLK-ID blk) (match-str pkt) (MATCH-POS pkt) (KEY-POS pkt) (PREV-MATCH-POS pkt)
  45.          (and prev-ent (ENT-SEG prev-ent)) (and prev-ent (ENT-ID prev-ent)) prev-pos))
  46.     (cond ((and (eq? (MATCH-TYPE pkt) PASTEND) (not (END-OF-CHAIN? blk)))
  47.        (let* ((nxt-num (BLK-NXT-ID blk))
  48.              (seg (ENT-SEG ent))
  49.           (nent #f)
  50.           (empty-blk? (eq? (MATCH-POS pkt) BLK-DATA-START))
  51.           (ppos (if empty-blk?
  52.                 prev-pos
  53.                 ;(blk-prev-key blk (MATCH-POS pkt))
  54.                 (PREV-MATCH-POS pkt)
  55.                 )))
  56.          (if trace-on
  57.            (fprintf diagout "c-f-p nxt=%d empty=%d ppos=%d\\n"
  58.                    nxt-num empty-blk? ppos))
  59.          (cond (empty-blk?
  60.             (release-ent! ent access))
  61.            (else
  62.             (if prev-ent (release-ent! prev-ent #f))
  63.             (ent-update-access ent access #f)
  64.             (set! prev-ent ent)))
  65.          (set! nent (get-ent seg nxt-num access))
  66.          (chain-prev-find nent access key-str k-len pkt prev-ent ppos)))
  67.       ((eq? (MATCH-POS pkt) BLK-DATA-START) ; KEY found, but
  68.                                           ; PREV(KEY) in prev block
  69.        (cond (prev-ent
  70.           (release-ent! ent access)
  71.           (ent-update-access prev-ent #f access) ;need to back out if #f
  72.           (SET-MATCH-TYPE! pkt MATCH)
  73.           (if trace-on
  74.             (fprintf diagout "cfp-res1=MATCH at %d pos=%d\\n"
  75.                      (ENT-ID prev-ent) prev-pos))
  76.           (SET-MATCH-POS! pkt prev-pos)
  77.           prev-ent)
  78.          (else
  79.           (SET-MATCH-TYPE! pkt PASTEND)
  80.           (if trace-on
  81.             (fprintf diagout "cfp-res3=PASTEND prev-ent=NONE pos=%d\\n"
  82.                      prev-pos))
  83.           (SET-MATCH-POS! pkt 0)
  84.           ent)))
  85.       (else                ; found, current block
  86.        (if prev-ent (release-ent! prev-ent #f))
  87.        (SET-MATCH-TYPE! pkt MATCH)
  88.        (SET-MATCH-POS! pkt (PREV-MATCH-POS pkt))
  89. ;       (SET-MATCH-POS! pkt (blk-prev-key blk (MATCH-POS pkt)))
  90.        (if trace-on
  91.          (fprintf diagout "cfp-res2=MATCH at %d pos=%d\\n"
  92.                  (BLK-ID blk) (MATCH-POS pkt)))
  93.        ent))))
  94.  
  95. (define (str-gtr? a-str a-pos a-len b-str b-pos b-len)
  96.   (let loop ((i 0) (ap a-pos) (bp b-pos))
  97.     (cond ((>= i a-len) #f)
  98.       ((>= i b-len) #t)
  99.       ((char<? (string-ref a-str ap) (string-ref b-str bp)) #f)
  100.       ((char<? (string-ref b-str bp) (string-ref a-str ap)) #t)
  101.       (else (loop (+ i 1) (+ ap 1) (+ bp 1))))))
  102.  
  103. ;; PREV-KEY-ENT [was PREV-KEY] assumes entry with #f access to BLK.
  104. ;; It either returns the  entry contining PREV(key) (with READ access)
  105. ;; (and pos(prev) in PKT, type=MATCH) or #f, if there is no such key.
  106. ;; call PREV-KEY-ENT with ROOT block...
  107.  
  108. ;; NOTE: PREV-K-ENT still needs the PENT kluge to keep the block unchanged while it works.
  109.  
  110. (define (prev-k-ent ent key-str k-len level pkt)
  111.   (and ent                ; this is also not an "error"
  112.                     ; keep ptr to blk till we verify its PREV...
  113.        (let ((pent (get-ent (ENT-SEG ent) (ENT-ID ent) #f)))
  114.      (set! ent (chain-prev-find ent ACCREAD key-str k-len pkt #f 0))
  115.      (if trace-on
  116.          (fprintf diagout "prev-key-ent now at blk=%d:%ld cfp: res=[%s mpos=%d kpos=%d ppos=%d]\\n"
  117.               (and ent (ENT-SEG ent)) (and ent (ENT-ID ent))
  118.               (match-str pkt) (MATCH-POS pkt) (KEY-POS pkt) (PREV-MATCH-POS pkt)))
  119.                     ; "[and ent" deleted -- rjz
  120.      (let ((res-ent (if (eq? (MATCH-TYPE pkt) MATCH)
  121.             ent
  122.             (begin
  123.               (release-ent! ent ACCREAD)
  124.               (prev-k-ent (prev-blk-ent pent level)
  125.                       key-str k-len level pkt)))))
  126.        (release-ent! pent #f)
  127.        res-ent))))
  128.  
  129. (define (prev-key-ent ent key-str k-len level pkt)
  130.   (if trace-on
  131.       (and ent
  132.        (fprintf diagout "prev-key-ent called key=%.*s level=%d blk=%d:%ld\\n"
  133.             (max 0 k-len) key-str level (ENT-SEG ent) (ENT-ID ent))))
  134.   (and
  135.    ent
  136.    (prev-k-ent (find-prev-ent ent level -1 key-str k-len) key-str k-len level pkt)))
  137.  
  138. ;; CHAIN-TO-PREV-ENT: subroutine for PREV-BLK-ENT
  139. ;; this routine chains fwd from FROM-ENT to imm predecessor of GOAL-BLK
  140. ;; called with FROM-ENT open with ACCREAD; assumes GOAL-BLOCK-NO Name-locked
  141. ;; returns an ENT open ACCREAD unless missed block, which returns #f
  142. ;; (routine also checks if its past key)
  143.  
  144. (define (chain-to-prev-ent from-ent goal-blk-num goal-key-str key-len)
  145.   (let ((from-blk (ENT-BLK from-ent)))
  146.     (if trace-on (fprintf diagout "chain-to-prev-ent from %d:%ld to %d\\n"
  147.               (ENT-SEG from-ent) (ENT-ID from-ent) goal-blk-num))
  148.     (if (= (BLK-NXT-ID from-blk) goal-blk-num) from-ent
  149.     (if (END-OF-CHAIN? from-blk)
  150.         (begin (fprintf diagout
  151.                 ">>>>ERROR<<<< chain-to-prev-ent: hit end of %d:ld lev=%d %.*s\\n"
  152.                 (ENT-ID from-ent) goal-blk-num (BLK-LEVEL from-blk) key-len goal-key-str)
  153.            #f)
  154.         (let ((b-pos BLK-DATA-START))
  155.           (if (str-gtr? from-blk (+ b-pos 2) (FIELD-LEN from-blk (+ b-pos 1))
  156.                 goal-key-str 0 key-len)
  157.           (begin
  158.             (fprintf diagout
  159.                  ">>>>ERROR<<<< chain-to-prev-ent: missed blk %d:ld lev=%d %.*s\\n"
  160.                  (ENT-ID from-ent) goal-blk-num (BLK-LEVEL from-blk) key-len goal-key-str)
  161.             #f)
  162.           (chain-to-prev-ent
  163.            (switch-ent from-ent ACCREAD (BLK-NXT-ID from-blk) ACCREAD)
  164.            goal-blk-num goal-key-str key-len )))))))
  165.  
  166. ;; there must be a more efficient way to check this !!!
  167. (define (at-root-level? seg blk)
  168.   (if (ROOT? blk) #t
  169.       (let* ((rent (get-ent seg (BLK-TOP-ID blk) ACCREAD))
  170.          (rblk (ENT-BLK rent))
  171.          (rlevel (BLK-LEVEL rblk))
  172.          (res (= (BLK-LEVEL blk) rlevel)))
  173.     (if trace-on
  174.         (fprintf diagout "at-root-level blk=%d:%ld rootlvl=%d result=%d\\n"
  175.              seg (BLK-ID blk) rlevel res))
  176.     (release-ent! rent ACCREAD)
  177.     res)))
  178.  
  179. ;; PREV-BLK-ENT [was PREV-BLK] is called with ENT (with #f access)
  180. ;; which IS PRESERVED. IT finds the block that precedes ENT, or #f.
  181. ;; It returns a (second) entry with READ access or #f.
  182. ;;; TBD - shouldn't it release ENT if returning #f?
  183. ;; (no, not as things are now -- rjz)
  184.  
  185. (define (prev-blk-ent ent level)
  186.   (ent-update-access ent #f ACCREAD)    ;need to back out if #f
  187.   (let* ((blk (ENT-BLK ent)))
  188.     (if trace-on (fprintf diagout "prev-blk-ent blk=%d:%ld level=%d\\n"
  189.               (ENT-SEG ent) (ENT-ID ent) level))
  190.     (ent-update-access ent ACCREAD #f)
  191.     (if
  192.      (ROOT? blk) #f        ;this is not an error, its AT-START-OF-TREE
  193.      (let ((skey-pos (split-key-pos blk)))
  194.        (and
  195.     skey-pos
  196.     (let* ((top-num (BLK-TOP-ID blk))
  197.            (seg (ENT-SEG ent))
  198.            (goal-blk-num (ENT-ID ent))
  199.            (new-str (make-string 256))
  200.            (k-len (recon-this-key blk skey-pos new-str 0 256)))
  201.       (if
  202.        (at-root-level? seg blk)
  203.        (begin
  204.          (fprintf diagout "PREV-BLK-ENT code which has never been run!!!!!\\n")
  205.          (chain-to-prev-ent (get-ent seg top-num ACCREAD)
  206.                 goal-blk-num new-str k-len))
  207.        (let ((pkt (make-vector PKT-SIZE)))
  208.          (if trace-on
  209.          (fprintf diagout "prev-blk-ent calling prev-key-ent key= %.*s\\n"
  210.               (max 0 k-len) new-str))
  211.          (set! ent (prev-key-ent (get-ent seg top-num #f)
  212.                      new-str k-len (+ level 1) pkt))
  213.          (if (eq? ent #f) #f
  214.          (let ((nxt-pos (next-field (ENT-BLK ent) (+ 1 (MATCH-POS pkt)))))
  215.            (chain-to-prev-ent
  216.             (switch-ent
  217.              ent ACCREAD
  218.              (str2long
  219.               (ENT-BLK ent)
  220.               (if (= nxt-pos (BLK-END (ENT-BLK ent)))
  221.               (begin
  222.                 (fprintf
  223.                  diagout
  224.                  "PREV-BLK-ENT: I'm confused: at split key of blk %d:%ld"
  225.                  (ENT-SEG ent) (ENT-ID ent))
  226.                 (- (MATCH-POS pkt) 4))
  227.               (+ 1 nxt-pos)))
  228.              ACCREAD)
  229.             goal-blk-num new-str k-len)))))
  230.                            ;;; get split key of this blk
  231.       ))))))
  232.  
  233. ;; FIND-PREV-ENT: called (like FIND-NEXT) with #f access on ENT.
  234. ;; Returns a new ENT with ACCREAD access. Will always return an ENT
  235. ;; unless some GET-ENT fails.
  236.  
  237. (define (find-prev-ent ent desired-level last-level key-str k-len)
  238.   (if trace-on
  239.       (fprintf diagout "find-prev-ent dlevel=%d key=%.*s %d:%ld\\n"
  240.            desired-level (max 0 k-len) key-str (ENT-SEG ent) (ENT-ID ent)))
  241.   (and
  242.    ent
  243.    (ent-update-access ent #f ACCREAD)    ;need to back out if #f
  244.    (let ((blk (ENT-BLK ent)))
  245.      (cond ((= (BLK-LEVEL blk) desired-level) ent)
  246.        ((< (BLK-LEVEL blk) desired-level)
  247.         (fprintf diagout ">>>>ERROR<<<< find-prev-ent: bad blk level\\n")
  248.         #f)
  249.        ((and (>= last-level 0)
  250.          (not (= (BLK-LEVEL blk) (- last-level 1))))
  251.         (fprintf diagout ">>>>ERROR<<<< find-prev-ent: bad blk level %d last=%d in %d:%ld\\n"
  252.              (BLK-LEVEL blk) last-level (ENT-SEG ent) (ENT-ID ent))
  253.         #f)
  254.        (else
  255.         (let ((pkt (make-vector PKT-SIZE)))
  256.           (set! ent (chain-find ent ACCREAD key-str k-len pkt))
  257.           (and ent
  258.            (let* ((nxt-pos (next-field (ENT-BLK ent) (+ 1 (MATCH-POS pkt))))
  259.               (ptr-pos (if (= nxt-pos (BLK-END (ENT-BLK ent)))
  260.                        (- (MATCH-POS pkt) 4)
  261.                        (+ 1 nxt-pos))))
  262.              (if trace-on
  263.              (fprintf diagout "find-prev-ent: at %d:%ld pos=%d next=%d ptrpos=%d\\n"
  264.                   (ENT-SEG ent) (ENT-ID ent) (MATCH-POS pkt) nxt-pos ptr-pos))
  265.              (find-prev-ent
  266.               (switch-ent ent ACCREAD
  267.                   (str2long (ENT-BLK ent) ptr-pos) #f)
  268.               desired-level (BLK-LEVEL (ENT-BLK ent)) key-str k-len)))))))))
  269.